home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _bcba514dfdbef0c5bda92d77a7526f43 < prev    next >
Encoding:
Text File  |  2002-05-30  |  13.1 KB  |  665 lines
  1. package Tk::HList;
  2.  
  3. use vars qw($VERSION);
  4. $VERSION = '3.035'; # $Id: //depot/Tk8/HList/HList.pm#35 $
  5.  
  6. use Tk qw(Ev $XS_VERSION);
  7.  
  8. use base  qw(Tk::Widget);
  9.  
  10. Construct Tk::Widget 'HList';
  11. sub Tk::Widget::ScrlHList { shift->Scrolled('HList'=>@_) }
  12.  
  13. bootstrap Tk::HList;
  14.  
  15. sub Tk_cmd { \&Tk::hlist }
  16.  
  17. sub CreateArgs
  18. {
  19.  my ($package,$parent,$args) = @_;
  20.  my @result = $package->SUPER::CreateArgs($parent,$args);
  21.  my $columns = delete $args->{-columns};
  22.  push(@result, '-columns' => $columns) if (defined $columns);
  23.  return @result;
  24. }
  25.  
  26. Tk::Methods qw(add addchild anchor column
  27.                delete dragsite dropsite entrycget
  28.                entryconfigure geometryinfo indicator header hide item info
  29.                nearest see select selection show xview yview);
  30.  
  31. use Tk::Submethods ( 'delete'    => [qw(all entry offsprings siblings)],
  32.                      'header'    => [qw(configure cget create delete exists size)],
  33.                      'indicator' => [qw(configure cget create delete exists size)],
  34.                      'info'      => [qw(anchor bbox children data dragsite
  35.                                      dropsite exists hidden item next parent prev
  36.                                      selection)],
  37.                      'item'      => [qw(configure cget create delete exists)],
  38.                      'selection' => [qw(clear get includes set)],
  39.                      'anchor'    => [qw(clear set)],
  40.                      'column'    => [qw(width)],
  41.                      'hide'      => [qw(entry)],
  42.                    );
  43.  
  44.  
  45. sub ClassInit
  46. {
  47.  my ($class,$mw) = @_;
  48.  
  49.  $mw->bind($class,'<ButtonPress-1>',[ 'Button1' ] );
  50.  $mw->bind($class,'<Shift-ButtonPress-1>',[ 'ShiftButton1' ] );
  51.  $mw->bind($class,'<Control-ButtonRelease-1>','Control_ButtonRelease_1');
  52.  $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
  53.  $mw->bind($class,'<Double-ButtonRelease-1>','NoOp');
  54.  $mw->bind($class,'<B1-Motion>',[ 'Button1Motion' ] );
  55.  $mw->bind($class,'<B1-Leave>',[ 'AutoScan' ] );
  56.  
  57.  $mw->bind($class,'<Double-ButtonPress-1>',['Double1']);
  58.  
  59.  $mw->bind($class,'<Control-B1-Motion>','Control_B1_Motion');
  60.  $mw->bind($class,'<Control-ButtonPress-1>',['CtrlButton1']);
  61.  $mw->bind($class,'<Control-Double-ButtonPress-1>',['CtrlButton1']);
  62.  
  63.  $mw->bind($class,'<B1-Enter>','B1_Enter');
  64.  
  65.  $mw->bind($class,'<Up>',['UpDown', 'prev']);
  66.  $mw->bind($class,'<Down>',['UpDown', 'next']);
  67.  
  68.  $mw->bind($class,'<Shift-Up>',['ShiftUpDown', 'prev']);
  69.  $mw->bind($class,'<Shift-Down>',['ShiftUpDown', 'next']);
  70.  
  71.  $mw->bind($class,'<Left>', ['LeftRight', 'left']);
  72.  $mw->bind($class,'<Right>',['LeftRight', 'right']);
  73.  
  74.  $mw->PriorNextBind($class);
  75.  
  76.  $mw->bind($class,'<Return>', ['KeyboardActivate']);
  77.  $mw->bind($class,'<space>',  ['KeyboardBrowse']);
  78.  $mw->bind($class,'<Home>',   ['KeyboardHome']);
  79.  $mw->bind($class,'<End>',    ['KeyboardEnd']);
  80.  
  81.  return $class;
  82. }
  83.  
  84. sub Control_ButtonRelease_1
  85. {
  86. }
  87.  
  88. sub ButtonRelease_1
  89. {
  90.  my $w = shift;
  91.  my $Ev = $w->XEvent;
  92.  $w->CancelRepeat
  93.  if($w->cget('-selectmode') ne 'dragdrop');
  94.  $w->ButtonRelease1($Ev);
  95. }
  96.  
  97. sub Control_B1_Motion
  98. {
  99. }
  100.  
  101. sub B1_Enter
  102. {
  103.  my $w = shift;
  104.  my $Ev = $w->XEvent;
  105.  $w->CancelRepeat
  106.  if($w->cget('-selectmode') ne 'dragdrop');
  107. }
  108.  
  109. sub Button1
  110. {
  111.  my $w = shift;
  112.  my $Ev = $w->XEvent;
  113.  
  114.  delete $w->{'shiftanchor'};
  115.  delete $w->{tixindicator};
  116.  
  117.  $w->focus() if($w->cget('-takefocus'));
  118.  
  119.  my $mode = $w->cget('-selectmode');
  120.  
  121.  if ($mode eq 'dragdrop')
  122.   {
  123.    # $w->Send_WaitDrag($Ev->y);
  124.    return;
  125.   }
  126.  
  127.  my $ent = $w->GetNearest($Ev->y, 1);
  128.  
  129.  if (!defined($ent) || !length($ent))
  130.   {
  131.     $w->selectionClear;
  132.     $w->anchorClear;
  133.     return;
  134.   }
  135.  
  136.  my @info = $w->info('item',$Ev->x, $Ev->y);
  137.  if (@info)
  138.   {
  139.    die 'Assert' unless $info[0] eq $ent;
  140.   }
  141.  else
  142.   {
  143.    @info = $ent;
  144.   }
  145.  
  146.  if (defined($info[1]) && $info[1] eq 'indicator')
  147.   {
  148.    $w->{tixindicator} = $ent;
  149.    $w->Callback(-indicatorcmd => $ent, '<Arm>');
  150.   }
  151.  else
  152.   {
  153.    my $browse = 0;
  154.  
  155.    if ($mode eq 'single')
  156.     {
  157.      $w->anchorSet($ent);
  158.     }
  159.    elsif ($mode eq 'browse')
  160.     {
  161.      $w->anchorSet($ent);
  162.      $w->selectionClear;
  163.      $w->selectionSet($ent);
  164.      $browse = 1;
  165.     }
  166.    elsif ($mode eq 'multiple')
  167.     {
  168.      $w->selectionClear;
  169.      $w->anchorSet($ent);
  170.      $w->selectionSet($ent);
  171.      $browse = 1;
  172.     }
  173.    elsif ($mode eq 'extended')
  174.     {
  175.      $w->anchorSet($ent);
  176.      $w->selectionClear;
  177.      $w->selectionSet($ent);
  178.      $browse = 1;
  179.     }
  180.  
  181.    if ($browse)
  182.     {
  183.      $w->Callback(-browsecmd => @info);
  184.     }
  185.   }
  186. }
  187.  
  188. sub ShiftButton1
  189. {
  190.  my $w = shift;
  191.  my $Ev = $w->XEvent;
  192.  
  193.  my $to = $w->GetNearest($Ev->y, 1);
  194.  
  195.  delete $w->{'shiftanchor'};
  196.  delete $w->{tixindicator};
  197.  
  198.  return unless (defined($to) and length($to));
  199.  
  200.  my $mode = $w->cget('-selectmode');
  201.  
  202.  if($mode eq 'extended' or $mode eq 'multiple')
  203.   {
  204.    my $from = $w->info('anchor');
  205.    if(defined $from)
  206.     {
  207.      $w->selectionClear;
  208.      $w->selectionSet($from, $to);
  209.     }
  210.    else
  211.     {
  212.      $w->anchorSet($to);
  213.      $w->selectionClear;
  214.      $w->selectionSet($to);
  215.     }
  216.   }
  217. }
  218.  
  219. sub GetNearest
  220. {
  221.  my ($w,$y,$undefafterend) = @_;
  222.  my $ent = $w->nearest($y);
  223.  if (defined $ent)
  224.   {
  225.    if ($undefafterend)
  226.     {
  227.      my $borderwidth = $w->cget('-borderwidth');
  228.      my $highlightthickness = $w->cget('-highlightthickness');
  229.      my $bottomy = ($w->infoBbox($ent))[3];
  230.      $bottomy += $borderwidth + $highlightthickness;
  231.      if ($w->header('exist', 0)){ $bottomy += ($w->header('size', 0))[1]; };
  232.      if ($y > $bottomy){ return undef; }
  233.     }
  234.    my $state = $w->entrycget($ent, '-state');
  235.    return $ent if (!defined($state) || $state ne 'disabled');
  236.   }
  237.  return undef;
  238. }
  239.  
  240. sub ButtonRelease1
  241. {
  242.  my ($w, $Ev) = @_;
  243.  
  244.  delete $w->{'shiftanchor'};
  245.  
  246.  my $mode = $w->cget('-selectmode');
  247.  
  248.  if($mode eq 'dragdrop')
  249.   {
  250. #   $w->Send_DoneDrag();
  251.    return;
  252.   }
  253.  
  254.  my ($x, $y) = ($Ev->x, $Ev->y);
  255.  my $ent = $w->GetNearest($y, 1);
  256.  
  257.  if (!defined($ent) and $mode eq 'single')
  258.   {
  259.      my $ent = $w->info('selection');
  260.      if (defined $ent)
  261.       {
  262.         $w->anchorSet($ent);
  263.       }
  264.   }
  265.  return unless (defined($ent) and length($ent));
  266.  
  267.  if(exists $w->{tixindicator})
  268.   {
  269.    return unless delete($w->{tixindicator}) eq $ent;
  270.    my @info = $w->info('item',$Ev->x, $Ev->y);
  271.    if(defined($info[1]) && $info[1] eq 'indicator')
  272.     {
  273.      $w->Callback(-indicatorcmd => $ent, '<Activate>');
  274.     }
  275.    return;
  276.   }
  277.  
  278.   if($mode eq 'single' || $mode eq 'browse')
  279.    {
  280.     $w->anchorSet($ent);
  281.     $w->selectionClear;
  282.     $w->selectionSet($ent);
  283.  
  284.    }
  285.   elsif($mode eq 'multiple')
  286.    {
  287.     $w->selectionSet($ent);
  288.    }
  289.   elsif($mode eq 'extended')
  290.    {
  291.     $w->selectionSet($ent);
  292.    }
  293.  
  294.  $w->Callback(-browsecmd =>$ent);
  295. }
  296.  
  297. sub Button1Motion
  298. {
  299.  my $w = shift;
  300.  my $Ev = $w->XEvent;
  301.  return unless defined $Ev;
  302.  
  303.  delete $w->{'shiftanchor'};
  304.  
  305.  my $mode = $w->cget('-selectmode');
  306.  
  307.  if ($mode eq 'dragdrop')
  308.   {
  309. #   $w->Send_StartDrag();
  310.    return;
  311.   }
  312.  
  313.  my $ent;
  314.  if (defined $w->info('anchor'))
  315.   {
  316.    $ent = $w->GetNearest($Ev->y);
  317.   }
  318.  else
  319.   {
  320.    $ent = $w->GetNearest($Ev->y, 1);
  321.   }
  322.  return unless (defined($ent) and length($ent));
  323.  
  324.  if(exists $w->{tixindicator})
  325.   {
  326.    my $event_type = $w->{tixindicator} eq $ent ? '<Arm>' : '<Disarm>';
  327.    $w->Callback(-indicatorcmd => $w->{tixindicator}, $event_type );
  328.    return;
  329.   }
  330.  
  331.  if ($mode eq 'single')
  332.   {
  333.    $w->anchorSet($ent);
  334.   }
  335.  elsif ($mode eq 'multiple' || $mode eq 'extended')
  336.   {
  337.    my $from = $w->info('anchor');
  338.    if(defined $from)
  339.     {
  340.      $w->selectionClear;
  341.      $w->selectionSet($from, $ent);
  342.     }
  343.    else
  344.     {
  345.      $w->anchorSet($ent);
  346.      $w->selectionClear;
  347.      $w->selectionSet($ent);
  348.     }
  349.   }
  350.  
  351.  if ($mode ne 'single')
  352.   {
  353.    $w->Callback(-browsecmd =>$ent);
  354.   }
  355. }
  356.  
  357. sub Double1
  358. {
  359.  my $w = shift;
  360.  my $Ev = $w->XEvent;
  361.  
  362.  delete $w->{'shiftanchor'};
  363.  
  364.  my $ent = $w->GetNearest($Ev->y, 1);
  365.  
  366.  return unless (defined($ent) and length($ent));
  367.  
  368.  $w->anchorSet($ent)
  369.     unless(defined $w->info('anchor'));
  370.  
  371.  $w->selectionSet($ent);
  372.  
  373.  $w->Callback(-command => $ent);
  374. }
  375.  
  376. sub CtrlButton1
  377. {
  378.  my $w = shift;
  379.  my $Ev = $w->XEvent;
  380.  
  381.  delete $w->{'shiftanchor'};
  382.  
  383.  my $ent = $w->GetNearest($Ev->y, 1);
  384.  
  385.  return unless (defined($ent) and length($ent));
  386.  
  387.  my $mode = $w->cget('-selectmode');
  388.  
  389.  if($mode eq 'extended')
  390.   {
  391.    $w->anchorSet($ent) unless( defined $w->info('anchor') );
  392.  
  393.    if($w->select('includes', $ent))
  394.     {
  395.      $w->select('clear', $ent);
  396.     }
  397.    else
  398.     {
  399.      $w->selectionSet($ent);
  400.     }
  401.    $w->Callback(-browsecmd =>$ent);
  402.   }
  403. }
  404.  
  405. sub UpDown
  406. {
  407.  my $w = shift;
  408.  my $spec = shift;
  409.  
  410.  my $done = 0;
  411.  my $anchor = $w->info('anchor');
  412.  
  413.  delete $w->{'shiftanchor'};
  414.  
  415.  unless( defined $anchor )
  416.   {
  417.    $anchor = ($w->info('children'))[0] || '';
  418.  
  419.    return unless (defined($anchor) and length($anchor));
  420.  
  421.    if($w->entrycget($anchor, '-state') ne 'disabled')
  422.     {
  423.      # That's a good anchor
  424.      $done = 1;
  425.     }
  426.    else
  427.     {
  428.      # We search for the first non-disabled entry (downward)
  429.      $spec = 'next';
  430.     }
  431.   }
  432.  
  433.  my $ent = $anchor;
  434.  
  435.  # Find the prev/next non-disabled entry
  436.  #
  437.  while(!$done)
  438.   {
  439.    $ent = $w->info($spec, $ent);
  440.    last unless( defined $ent );
  441.    next if( $w->entrycget($ent, '-state') eq 'disabled' );
  442.    next if( $w->info('hidden', $ent) );
  443.    last;
  444.   }
  445.  
  446.  unless( defined $ent )
  447.   {
  448.    $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
  449.    return;
  450.   }
  451.  
  452.  $w->anchorSet($ent);
  453.  $w->see($ent);
  454.  
  455.  if($w->cget('-selectmode') ne 'single')
  456.   {
  457.    $w->selectionClear;
  458.    $w->selection('set', $ent);
  459.    $w->Callback(-browsecmd =>$ent);
  460.   }
  461. }
  462.  
  463. sub ShiftUpDown
  464. {
  465.  my $w = shift;
  466.  my $spec = shift;
  467.  
  468.  my $mode = $w->cget('-selectmode');
  469.  
  470.  return $w->UpDown($spec)
  471.    if($mode eq 'single' || $mode eq 'browse');
  472.  
  473.  my $anchor = $w->info('anchor');
  474.  
  475.  return $w->UpDown($spec) unless (defined($anchor) and length($anchor));
  476.  
  477.  my $done = 0;
  478.  
  479.  $w->{'shiftanchor'} = $anchor unless( $w->{'shiftanchor'} );
  480.  
  481.  my $ent = $w->{'shiftanchor'};
  482.  
  483.  while( !$done )
  484.   {
  485.    $ent = $w->info($spec, $ent);
  486.    last unless( defined $ent );
  487.    next if( $w->entrycget($ent, '-state') eq 'disabled' );
  488.    next if( $w->info('hidden', $ent) );
  489.    last;
  490.   }
  491.  
  492.  unless( $ent )
  493.   {
  494.    $w->yview('scroll', $spec eq 'prev' ? -1 : 1, 'unit');
  495.    return;
  496.   }
  497.  
  498.  $w->selectionClear;
  499.  $w->selection('set', $anchor, $ent);
  500.  $w->see($ent);
  501.  
  502.  $w->{'shiftanchor'} = $ent;
  503.  
  504.  $w->Callback(-browsecmd =>$ent);
  505. }
  506.  
  507. sub LeftRight
  508. {
  509.  my $w = shift;
  510.  my $spec = shift;
  511.  
  512.  delete $w->{'shiftanchor'};
  513.  
  514.  my $anchor = $w->info('anchor');
  515.  
  516.  unless(defined $anchor)
  517.   {
  518.    $anchor = ($w->info('children'))[0] || '';
  519.   }
  520.  
  521.  my $done = 0;
  522.  my $ent = $anchor;
  523.  
  524.  while(!$done)
  525.   {
  526.    my $e = $ent;
  527.  
  528.    if($spec eq 'left')
  529.     {
  530.      $ent = $w->info('parent', $e);
  531.  
  532.      $ent = $w->info('prev', $e)
  533.        unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled')
  534.     }
  535.    else
  536.     {
  537.      $ent = ($w->info('children', $e))[0];
  538.  
  539.      $ent = $w->info('next', $e)
  540.        unless(defined $ent && $w->entrycget($ent, '-state') ne 'disabled')
  541.     }
  542.  
  543.    last unless( defined $ent );
  544.    last if($w->entrycget($ent, '-state') ne 'disabled');
  545.   }
  546.  
  547.  unless( defined $ent )
  548.   {
  549.    $w->xview('scroll', $spec eq 'left' ? -1 : 1, 'unit');
  550.    return;
  551.   }
  552.  
  553.  $w->anchorSet($ent);
  554.  $w->see($ent);
  555.  
  556.  if($w->cget('-selectmode') ne 'single')
  557.   {
  558.    $w->selectionClear;
  559.    $w->selectionSet($ent);
  560.  
  561.    $w->Callback(-browsecmd =>$ent);
  562.   }
  563. }
  564.  
  565. sub KeyboardHome
  566. {
  567.  my $w = shift;
  568.  $w->yview('moveto' => 0);
  569.  $w->xview('moveto' => 0);
  570. }
  571.  
  572. sub KeyboardEnd
  573. {
  574.  my $w = shift;
  575.  $w->yview('moveto' => 1);
  576.  $w->xview('moveto' => 0);
  577. }
  578.  
  579. sub KeyboardActivate
  580. {
  581.  my $w = shift;
  582.  
  583.  my $anchor = $w->info('anchor');
  584.  
  585.  return unless (defined($anchor) and length($anchor));
  586.  
  587.  if($w->cget('-selectmode'))
  588.   {
  589.    $w->selectionClear;
  590.    $w->selectionSet($anchor);
  591.   }
  592.  
  593.  $w->Callback(-command => $anchor);
  594. }
  595.  
  596. sub KeyboardBrowse
  597. {
  598.  my $w = shift;
  599.  
  600.  my $anchor = $w->info('anchor');
  601.  
  602.  return unless (defined($anchor) and length($anchor));
  603.  
  604.  if ($w->indicatorExists($anchor))
  605.   {
  606.    $w->Callback(-indicatorcmd => $anchor);
  607.   }
  608.  
  609.  if($w->cget('-selectmode'))
  610.   {
  611.    $w->selectionClear;
  612.    $w->selectionSet($anchor);
  613.   }
  614.  $w->Callback(-browsecmd =>$anchor);
  615. }
  616.  
  617. sub AutoScan
  618. {
  619.  my ($w,$x,$y) = @_;
  620.  
  621.  return if ($w->cget('-selectmode') eq 'dragdrop');
  622.  if (@_ < 3)
  623.   {
  624.    my $Ev = $w->XEvent;
  625.    return unless defined $Ev;
  626.    $y = $Ev->y;
  627.    $x = $Ev->x;
  628.   }
  629.  
  630.  if($y >= $w->height)
  631.   {
  632.    $w->yview('scroll', 1, 'units');
  633.   }
  634.  elsif($y < 0)
  635.   {
  636.    $w->yview('scroll', -1, 'units');
  637.   }
  638.  elsif($x >= $w->width)
  639.   {
  640.    $w->xview('scroll', 2, 'units');
  641.   }
  642.  elsif($x < 0)
  643.   {
  644.    $w->xview('scroll', -2, 'units');
  645.   }
  646.  else
  647.   {
  648.    return;
  649.   }
  650.  $w->RepeatId($w->SUPER::after(50,[ AutoScan => $w, $x, $y ]));
  651.  $w->Button1Motion;
  652. }
  653.  
  654. sub children
  655. {
  656.  # Tix has core-tk window(s) which are not a widget(s)
  657.  # the generic code returns these as an "undef"
  658.  my $w = shift;
  659.  my @info = grep(defined($_),$w->winfo('children'));
  660.  @info;
  661. }
  662.  
  663. 1;
  664.  
  665.